-- card: 3698 from stack: in.3
-- bmap block id: 0
-- flags: 4000
-- background id: 3241
-- name: PICTFileToRes
----- HyperTalk script -----
on Install
  get ChooseTargetStack()
  InstallResource XFCN,PICTFileToRes,it
end Install


-- part 1 (button)
-- low flags: 00
-- high flags: A003
-- rect: left=83 top=300 right=322 bottom=183
-- title width / last selected line: 0
-- icon id / first selected line: 0 / 0
-- text alignment: 1
-- font id: 0
-- text size: 12
-- style flags: 0
-- line height: 16
-- part name: PICTFileToRes
----- HyperTalk script -----
on mouseUp
  put PICTFileToRes()
end mouseUp



-- part 3 (button)
-- low flags: 00
-- high flags: A003
-- rect: left=299 top=300 right=322 bottom=438
-- title width / last selected line: 0
-- icon id / first selected line: 0 / 0
-- text alignment: 1
-- font id: 0
-- text size: 12
-- style flags: 0
-- line height: 16
-- part name: Show Pascal Source
----- HyperTalk script -----
on mouseUp
  set the visible of card field 1 to not the visible of card field 1
  if the visible of card field 1 is true then
    set the name of me to "Hide Pascal Source"
  else set the name of me to "Show Pascal Source"
end mouseUp



-- part 4 (field)
-- low flags: 81
-- high flags: 2007
-- rect: left=12 top=26 right=298 bottom=491
-- title width / last selected line: 0
-- icon id / first selected line: 0 / 0
-- text alignment: 0
-- font id: 22
-- text size: 10
-- style flags: 0
-- line height: 13
-- part name: Source


-- part contents for background part 16
----- text -----
PICTFILETORES XFCN version 1.6
Kevin Calhoun

PICTFileToRes creates a PICT resource from a PICT file and copies it into the current stack.  
You can tell PICTFileToRes what ID number you want the PICT resource to have or you can let it select an unused number for you.  If you choose a number that belongs to another PICT resource currently contained in your stack, the new picture will overwrite the old one.

PICTFileToRes allows the user to choose the PICT file to copy from from a standard file dialog box.  If the user presses Cancel instead of choosing a file, PICTFileToRes returns 
"Cancel".

As with other resource copiers, if you use PICTFileToRes to copy a PICT into the Home stack, you may have to quit and relaunch HyperCard in order to use it.

INVOKING PICTFILETORES

get PICTFileToRes(<pictID>,<"pictName">)

result:  resourceID

Both parameters are optional.  If you don't pass a value for pictID, PICTFileToRes will find an ID for the PICT resource that's not currently in use.  If you don't pass a value for pictName, the PICT resource will be unnamed.  If you pass a value for pictID or pictName that's already in use by another PICT resource in the current stack, the old PICT will be overwritten.

If an error occurs, PICTFileToRes will return an error message.  Word 1 of this message will be "Error."

EXAMPLES

put PICTFileToRes(0,"The Little Engine That Could") into pictNumber
get PICTFileToRes

REVISION HISTORY
1.0 -- 4/22/88
1.5 -- 3/15/89 -- Altered source for compatibility with MPW Pascal 3.0.
1.6 -- 7/22/89  No longer leaves a NIL master pointer behind when replacing a resource.

-- part contents for card part 4
----- text -----
UNIT PICTFileToResUnit;

{ PICTFileToRes XFCN © 1988-1989 by the Trustees of Dartmouth College }
{ Written by Kevin Calhoun }

{ This source compatible with MPW Pascal 3.0 }

(*
Pascal PICTFileToRes.p
Link -m ENTRYPOINT ∂
     -o "{boot}Hyper ƒ:Dartmouth XCMD's 3.1" ∂
     -rt XFCN=6483 ∂
     -sn Main=PICTFileToRes ∂
     PICTFileToRes.p.o ∂
     "{Libraries}"interface.o ∂
     "{PLibraries}"Paslib.o ∂
     "{Libraries}"HyperXLib.o
*)

{$R-}

INTERFACE
  USES
    Types,
    Memory,
    Resources,
    Files,
    Errors,
    Packages,
    HyperXCmd;

  CONST
    PictHeader = 512;

  PROCEDURE EntryPoint (paramPtr : XCMDPtr);

IMPLEMENTATION

  PROCEDURE ConvertPicture(paramPtr : XCMDPtr); FORWARD;

  PROCEDURE EntryPoint (paramPtr : XCMDPtr);
  BEGIN
    ConvertPicture(paramPtr);
  END;

  FUNCTION GetScreenBitsBounds: Rect;
  { get screenbits.bounds from the QuickDraw globals }
  TYPE
    LongwordPtr = ^LONGINT;
    BitMapPtr = ^BitMap;
  CONST
    screenBitsOffset = -122;
    CurrentA5 = $904;
  VAR
    screenBitsPtr : BitMapPtr;
    myLongwordPtr : LongwordPtr;
  BEGIN
    myLongwordPtr := LongwordPtr(CurrentA5);
      { myLongwordPtr now points to the pointer to the first QD global }
    myLongwordPtr := LongwordPtr(myLongwordPtr^);
      { myLongwordPtr now points to the first QD global }
    screenBitsPtr := BitMapPtr(myLongwordPtr^ + screenBitsOffset);
      { screenBitsPtr now points to the screenBits BitMap }
    GetScreenBitsBounds := screenBitsPtr^.bounds;
  END;

  FUNCTION GetTheNameOfThisStack (paramPtr : XCMDPtr; var str: Str255): OSErr;
    VAR
      theResult : Handle;
      theLength : Longint;
      err: OSErr;
  BEGIN
    err := noErr;
    str := 'word 2 of the long name of this stack';
    theResult := EvalExpr(paramPtr, str);
    err := paramPtr^.result;
    IF (theResult <> NIL) and (err = noErr) THEN
      BEGIN
      theLength := StringLength(paramPtr, theResult^);
      ZeroToPas(paramPtr, theResult^, str);
      DisposHandle(theResult);
      DELETE(str,theLength,1);
      DELETE(str,1,1);
      END
    ELSE str := '';
    GetTheNameOfThisStack := err;
  END;

  PROCEDURE ConvertPicture (paramPtr : XCMDPtr);
    LABEL
      98, 99, 100;
    VAR
      str : Str255;
      myStack : INTEGER;
      resAlready : Handle;
      parameterCount : INTEGER;
      id : INTEGER;
      name : Str255;
      SFGetReply : SFReply;
      where : point;
      theReadRefNum, curFile : INTEGER;
      { file ref numbers for file manager calls }
      err, closeErr : OSErr;
      logEOF : longint;
      theBufHndl : Handle;
      gotName, gotID: BOOLEAN;

    PROCEDURE PassReturnValue (theMsg : Str255); { set theResult and quit }
    BEGIN
      paramPtr^.returnValue := PasToZero(paramPtr, theMsg);
    END;

    PROCEDURE GetParameters;
    BEGIN
      gotID := FALSE;
      gotName := FALSE;
      name := '';
      IF parameterCount > 0 THEN
        BEGIN
          ZeroToPas(paramPtr, paramPtr^.params[1]^, str);
          if LENGTH(str) > 0 THEN gotID := TRUE;
          id := StrToNum(paramPtr, str);
          IF parameterCount > 1 THEN
            BEGIN
            ZeroToPas(paramPtr, paramPtr^.params[2]^, name);
            if LENGTH(name) > 0 THEN gotName := TRUE;
            END;
        END;
    END;

    PROCEDURE CheckForSameTypeIDName;
    BEGIN
      SetResLoad(FALSE);
      IF not gotID THEN
        REPEAT
          id := Unique1ID('PICT');
        UNTIL id > 127
      ELSE
        REPEAT
          resAlready := Get1Resource('PICT', id);
          IF resAlready <> NIL THEN
            BEGIN
              RmveResource(resAlready);
              DisposHandle(resAlready);
            END;
        UNTIL resAlready = NIL;

      IF gotName THEN
        REPEAT
          resAlready := Get1NamedResource('PICT', name);
          IF resAlready <> NIL THEN
            BEGIN
              RmveResource(resAlready);
              DisposHandle(resAlready);
            END;
        UNTIL resAlready = NIL;
      SetResLoad(TRUE);
    END;

    PROCEDURE DoSFGet;
      VAR
        where : point;
        typeList : SFTypeList;
        dlgt: DialogTHndl;
        r: rect;
        screen: rect;
        h, v: INTEGER;
    BEGIN  { select text file to read using SFGetFile }
      dlgt := DialogTHndl(GetResource('DLOG',getDlgID));
      if dlgt <> nil then
        begin
        r := dlgt^^.boundsRect;
        screen := GetScreenBitsBounds;
        h := ((screen.right - screen.left) - (r.right - r.left)) div 2;
        v := ((screen.bottom - screen.top) - (r.bottom - r.top)) div 2;
        SetPt(where, h, v);
        end
      else SetPt(where, 82, 75);
      typeList[0] := 'PICT';                { tell SFGetFile to display only text files }
      SFGetFile(where, '', NIL, 1, typeList, NIL, SFGetReply);          { call SFGetFile }
    END;

  BEGIN
    err := noErr;
    parameterCount := paramPtr^.paramCount;
    IF parameterCount > 2 THEN
      PassReturnValue('PICTFileToRes XFCN 1.6, 22 July 1989, ©1988-1989 Dartmouth College')
    ELSE
      BEGIN
      GetParameters;
      err := GetTheNameOfThisStack(paramPtr,str);
      IF err<>noErr THEN GOTO 100;
  
      myStack := OpenResFile(str);
      IF (myStack = -1) AND (ResError = eofErr) THEN
        BEGIN
          CreateResFile(str);
          err := ResError;
          IF err = noErr THEN
            myStack := OpenResFile(str);
        END;
      IF (myStack <= 0) OR (err <> noErr) THEN GOTO 100;
  
      DoSFGet;
      IF SFGetReply.good = FALSE THEN
        BEGIN
        PassReturnValue('Cancel');
        GOTO 100;
        END;
      { continue only if user actually selected a file }
  
      WITH SFGetReply DO
        err := FSOpen(fName, vRefNum, theReadRefNum);
      { open the file }
      IF err <> noErr THEN GOTO 100;
      { continue only if file could be opened }
  
      err := GetEOF(theReadRefNum, logEOF);
      IF err <> noErr THEN GOTO 99;
      
      { set up the buffer in memory for reading in logEOF bytes }
      theBufHndl := NewHandle(logEOF - PictHeader);
      err := MemError;
      { save the result in case we want to report an error }
      IF (theBufHndl = NIL) OR (err <> noErr) THEN GOTO 99;
     { continue only if enough memory is available }
  
      MoveHHi(theBufHndl);
      HLock(theBufHndl);  { lock down our buffer }
  { read logEOF bytes into the location pointed to by theBufHndl^ }
      err := SetFPos(theReadRefNum, fsFromStart, PictHeader);
      IF err <> noErr THEN
        BEGIN
        DisposHandle(theBufHndl);
        GOTO 99;
        END;
  
      logEOF := logEOF - PictHeader;
      err := FSRead(theReadRefNum, logEOF, theBufHndl^);
      IF err <> noErr THEN
        BEGIN
        DisposHandle(theBufHndl);
        GOTO 99;
        END;
      { continue only if the read worked }
        
      HNoPurge(theBufHndl);
      curFile := CurResFile;
      UseResFile(myStack);
      CheckForSameTypeIDName;
      AddResource(theBufHndl, 'PICT', id, name);
      err := ResError;
      IF err <> noErr THEN
        BEGIN
        DisposHandle(theBufHndl);
        GOTO 98;
        END;

      SetResAttrs(theBufHndl, resPurgeable + resChanged);
      WriteResource(theBufHndl);
      UpdateResFile(myStack);
      NumToStr(paramPtr, id, str);
      PassReturnValue(str);
      ReleaseResource(theBufHndl);
      98: UseResFile(curFile);
      99: closeErr := FSClose(theReadRefNum);
      100: if err <> noErr then
        BEGIN
        NumToStr(paramPtr, err, str);
        PassReturnValue(CONCAT('Error ', str));
        END;
      END;
  END;

END.